home *** CD-ROM | disk | FTP | other *** search
- ;;;-*-Mode:LISP; Package:(PCL LISP ); Base:10; Syntax:Common-lisp -*-
- ;;;
- ;;; *************************************************************************
- ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
- ;;; All rights reserved.
- ;;;
- ;;; Use and copying of this software and preparation of derivative works
- ;;; based upon this software are permitted. Any distribution of this
- ;;; software or derivative works must comply with all applicable United
- ;;; States export control laws.
- ;;;
- ;;; This software is made available AS IS, and Xerox Corporation makes no
- ;;; warranty about the software, its performance or its conformity to any
- ;;; specification.
- ;;;
- ;;; Any person obtaining a copy of this software is requested to send their
- ;;; name and post office or electronic mail address to:
- ;;; CommonLoops Coordinator
- ;;; Xerox PARC
- ;;; 3333 Coyote Hill Rd.
- ;;; Palo Alto, CA 94304
- ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
- ;;;
- ;;; Suggestions, comments and requests for improvements are also welcome.
- ;;; *************************************************************************
- ;;;
- ;;; Some support stuff for compiling and loading PCL. It would be nice if
- ;;; there was some portable make-system we could all agree to share for a
- ;;; while. At least until people really get databases and stuff.
- ;;;
- ;;; *** ***
- ;;; *** DIRECTIONS FOR INSTALLING PCL AT YOUR SITE ***
- ;;; *** ***
- ;;;
- ;;; To get PCL working at your site you should:
- ;;;
- ;;; - Get all the PCL source files from Xerox. The complete list of source
- ;;; file names can be found in the defsystem for PCL which appears towards
- ;;; the end of this file.
- ;;;
- ;;; - Edit the variable *pcl-directory* below to specify the directory at
- ;;; your site where the pcl sources and binaries will be. This variable
- ;;; can be found by searching from this point for the string "***" in
- ;;; this file.
- ;;;
- ;;; - Use the function (pcl::compile-pcl) to compile PCL for your site.
- ;;;
- ;;; - Once PCL has been compiled it can be loaded with (pcl::load-pcl).
- ;;; Note that PCL cannot be loaded on top of itself, nor can it be
- ;;; loaded into the same world it was compiled in.
- ;;;
-
- #+pcl
- (when (boundp 'pcl::*boot-state*)
- (warn "Lisp heap already had PCL package. Renaming it to OLD-PCL.")
- (rename-package "PCL" "OLD-PCL"))
-
- (in-package "PCL" :use (list (or (find-package :walker)
- (make-package :walker :use '(:lisp)))
- (or (find-package :iterate)
- (make-package :iterate
- :use '(:lisp :walker)))
- (find-package :lisp)))
-
- (export (intern (symbol-name :iterate) ;Have to do this here,
- (find-package :iterate)) ;because in the defsystem
- (find-package :iterate)) ;(later in this file)
- ;we use the symbol iterate
- ;to name the file
-
- ;;;
- ;;; Sure, its weird for this to be here, but in order to follow the rules
- ;;; about order of export and all that stuff, we can't put it in PKG before
- ;;; we want to use it.
- ;;;
- (defvar *the-pcl-package* (find-package :pcl))
-
- (defvar *pcl-system-date* "July 92 PCL (1b)")
-
- #+cmu
- (when (boundp 'ext::*herald-items*)
- (setf (getf ext::*herald-items* :pcl)
- `(" CLOS based on PCL version: " ,*pcl-system-date*)))
-
- ;;;
- ;;; Various hacks to get people's *features* into better shape.
- ;;;
- (eval-when (compile load eval)
-
- #+(and Symbolics Lispm)
- (multiple-value-bind (major minor) (sct:get-release-version)
- (etypecase minor
- (integer)
- (string (setf minor (parse-integer minor :junk-allowed t))))
- (pushnew :genera *features*)
- (ecase major
- ((6)
- (pushnew :genera-release-6 *features*))
- ((7)
- (pushnew :genera-release-7 *features*)
- (ecase minor
- ((0 1) (pushnew :genera-release-7-1 *features*))
- ((2) (pushnew :genera-release-7-2 *features*))
- ((3) (pushnew :genera-release-7-3 *features*))
- ((4) (pushnew :genera-release-7-4 *features*))))
- ((8)
- (pushnew :genera-release-8 *features*)
- (ecase minor
- ((0) (pushnew :genera-release-8-0 *features*))
- ((1) (pushnew :genera-release-8-1 *features*))))))
-
- #+CLOE-Runtime
- (let ((version (lisp-implementation-version)))
- (when (string-equal version "2.0" :end1 (min 3 (length version)))
- (pushnew :cloe-release-2 *features*)))
-
- (dolist (feature *features*)
- (when (and (symbolp feature) ;3600!!
- (equal (symbol-name feature) "CMU"))
- (pushnew :CMU *features*)))
-
- #+TI
- (if (eq (si:local-binary-file-type) :xld)
- (pushnew ':ti-release-3 *features*)
- (pushnew ':ti-release-2 *features*))
-
- #+Lucid
- (when (search "IBM RT PC" (machine-type))
- (pushnew :ibm-rt-pc *features*))
-
- #+ExCL
- (cond ((search "sun3" (lisp-implementation-version))
- (push :sun3 *features*))
- ((search "sun4" (lisp-implementation-version))
- (push :sun4 *features*)))
-
- #+(and HP Lucid)
- (push :HP-Lucid *features*)
- #+(and HP (not Lucid) (not excl))
- (push :HP-HPLabs *features*)
-
- #+Xerox
- (case il:makesysname
- (:lyric (push :Xerox-Lyric *features*))
- (otherwise (push :Xerox-Medley *features*)))
- ;;;
- ;;; For KCL and IBCL, push the symbol :turbo-closure on the list *features*
- ;;; if you have installed turbo-closure patch. See the file kcl-mods.text
- ;;; for details.
- ;;;
- ;;; The xkcl version of KCL has this fixed already.
- ;;;
-
- #+xkcl(pushnew :turbo-closure *features*)
-
- )
-
-
-
- ;;; Yet Another Sort Of General System Facility and friends.
- ;;;
- ;;; The entry points are defsystem and operate-on-system. defsystem is used
- ;;; to define a new system and the files with their load/compile constraints.
- ;;; Operate-on-system is used to operate on a system defined that has been
- ;;; defined by defsystem. For example:
- #||
-
- (defsystem my-very-own-system
- "/usr/myname/lisp/"
- ((classes (precom) () ())
- (methods (precom classes) (classes) ())
- (precom () (classes methods) (classes methods))))
-
- This defsystem should be read as follows:
-
- * Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries
- should be in the directory "/usr/me/lisp/". There are three files
- in the system, there are named classes, methods and precom. (The
- extension the filenames have depends on the lisp you are running in.)
-
- * For the first file, classes, the (precom) in the line means that
- the file precom should be loaded before this file is loaded. The
- first () means that no other files need to be loaded before this
- file is compiled. The second () means that changes in other files
- don't force this file to be recompiled.
-
- * For the second file, methods, the (precom classes) means that both
- of the files precom and classes must be loaded before this file
- can be loaded. The (classes) means that the file classes must be
- loaded before this file can be compiled. The () means that changes
- in other files don't force this file to be recompiled.
-
- * For the third file, precom, the first () means that no other files
- need to be loaded before this file is loaded. The first use of
- (classes methods) means that both classes and methods must be
- loaded before this file can be compiled. The second use of (classes
- methods) mean that whenever either classes or methods changes precom
- must be recompiled.
-
- Then you can compile your system with:
-
- (operate-on-system 'my-very-own-system :compile)
-
- and load your system with:
-
- (operate-on-system 'my-very-own-system :load)
-
- ||#
-
- ;;;
- (defvar *system-directory*)
-
- ;;;
- ;;; *port* is a list of symbols (in the PCL package) which represent the
- ;;; Common Lisp in which we are now running. Many of the facilities in
- ;;; defsys use the value of *port* rather than #+ and #- to conditionalize
- ;;; the way they work.
- ;;;
- (defvar *port*
- '(#+Genera Genera
- ; #+Genera-Release-6 Rel-6
- ; #+Genera-Release-7-1 Rel-7
- #+Genera-Release-7-2 Rel-7
- #+Genera-Release-7-3 Rel-7
- #+Genera-Release-7-1 Rel-7-1
- #+Genera-Release-7-2 Rel-7-2
- #+Genera-Release-7-3 Rel-7-2 ;OK for now
- #+Genera-Release-7-4 Rel-7-2 ;OK for now
- #+Genera-Release-8 Rel-8
- #+imach Ivory
- #+Cloe-Runtime Cloe
- #+Lucid Lucid
- #+Xerox Xerox
- #+Xerox-Lyric Xerox-Lyric
- #+Xerox-Medley Xerox-Medley
- #+TI TI
- #+(and dec vax common) Vaxlisp
- #+KCL KCL
- #+IBCL IBCL
- #+excl excl
- #+(and excl sun4) excl-sun4
- #+:CMU CMU
- #+HP-HPLabs HP-HPLabs
- #+:gclisp gclisp
- #+pyramid pyramid
- #+:coral coral
- #+CLISP CLISP))
-
- ;;;
- ;;; When you get a copy of PCL (by tape or by FTP), the sources files will
- ;;; have extensions of ".lisp" in particular, this file will be defsys.lisp.
- ;;; The preferred way to install pcl is to rename these files to have the
- ;;; extension which your lisp likes to use for its files. Alternately, it
- ;;; is possible not to rename the files. If the files are not renamed to
- ;;; the proper convention, the second line of the following defvar should
- ;;; be changed to:
- ;;; (let ((files-renamed-p nil)
- ;;;
- ;;; Note: Something people installing PCL on a machine running Unix
- ;;; might find useful. If you want to change the extensions
- ;;; of the source files from ".lisp" to ".lsp", *all* you have
- ;;; to do is the following:
- ;;;
- ;;; % foreach i (*.lisp)
- ;;; ? mv $i $i:r.lsp
- ;;; ? end
- ;;; %
- ;;;
- ;;; I am sure that a lot of people already know that, and some
- ;;; Unix hackers may say, "jeez who doesn't know that". Those
- ;;; same Unix hackers are invited to fix mv so that I can type
- ;;; "mv *.lisp *.lsp".
- ;;;
- (defvar *default-pathname-extensions*
- (car '(#+(and (not imach) genera) ("lisp" . "bin")
- #+(and imach genera) ("lisp" . "ibin")
- #+Cloe-Runtime ("l" . "fasl")
- #+(and dec common vax (not ultrix)) ("LSP" . "FAS")
- #+(and dec common vax ultrix) ("lsp" . "fas")
- #+KCL ("cl" . "o")
- #+IBCL ("lsp" . "o")
- #+Xerox ("lisp" . "dfasl")
- #+(and Lucid MC68000) ("lisp" . "lbin")
- #+(and Lucid VAX) ("lisp" . "vbin")
- #+(and Lucid Prime) ("lisp" . "pbin")
- #+(and Lucid SUNRise) ("lisp" . "sbin")
- #+(and Lucid SPARC) ("lisp" . "sbin")
- #+(and Lucid IBM-RT-PC) ("lisp" . "bbin")
- #+(and Lucid MIPS) ("lisp" . "mbin")
- #+(and Lucid PRISM) ("lisp" . "abin")
- #+(and Lucid PA) ("lisp" . "hbin")
- #+excl ("cl" . "fasl")
- #+(and excl SPARC) ("cl" . "sparc")
- #+(and excl m68k (not next)) ("cl" . "m68k")
- #+excl ("cl" . "fasl")
- #+cmu ("lisp" . #.(c:backend-fasl-file-type c:*backend*))
- #+HP-HPLabs ("l" . "b")
- #+TI ("lisp" . #.(string (si::local-binary-file-type)))
- #+:gclisp ("LSP" . "F2S")
- #+pyramid ("clisp" . "o")
- #+:coral ("cl" . "fasl")
- #+(and CLISP (or ATARI DOS)) ("LSP" . "FAS")
- #+(and CLISP (not (or ATARI DOS))) ("lsp" . "fas")
- #-(or symbolics (and dec common vax) KCL IBCL Xerox
- lucid excl :CMU HP TI :gclisp pyramid coral CLISP)
- ("lisp" . "lbin"))))
-
- (defvar *pathname-extensions*
- (let* ((files-renamed-p t)
- (proper-extensions *default-pathname-extensions*))
- (cond ((null proper-extensions) '("l" . "lbin"))
- ((null files-renamed-p) (cons "lisp" (cdr proper-extensions)))
- (t proper-extensions))))
-
- (eval-when (compile load eval)
-
- (defun get-system (name)
- (get name 'system-definition))
-
- (defun set-system (name new-value)
- (setf (get name 'system-definition) new-value))
-
- (defmacro defsystem (name directory files)
- `(set-system ',name (list #'(lambda () ,directory)
- (make-modules ',files)
- ',(mapcar #'car files))))
-
- )
-
-
- ;;;
- ;;; The internal datastructure used when operating on a system.
- ;;;
- (defstruct (module (:constructor make-module (name))
- (:print-function
- (lambda (m s d)
- (declare (ignore d))
- (format s "#<Module ~A>" (module-name m)))))
- name
- load-env
- comp-env
- recomp-reasons)
-
- (defun make-modules (system-description)
- (let ((modules ()))
- (labels ((get-module (name)
- (or (find name modules :key #'module-name)
- (progn (setq modules (cons (make-module name) modules))
- (car modules))))
- (parse-spec (spec)
- (if (eq spec 't)
- (reverse (cdr modules))
- (case (car spec)
- (+ (append (reverse (cdr modules))
- (mapcar #'get-module (cdr spec))))
- (- (let ((rem (mapcar #'get-module (cdr spec))))
- (remove-if #'(lambda (m) (member m rem))
- (reverse (cdr modules)))))
- (otherwise (mapcar #'get-module spec))))))
- (dolist (file system-description)
- (let* ((name (car file))
- (port (car (cddddr file)))
- (module nil))
- (when (or (null port)
- (member port *port*))
- (setq module (get-module name))
- (setf (module-load-env module) (parse-spec (cadr file))
- (module-comp-env module) (parse-spec (caddr file))
- (module-recomp-reasons module) (parse-spec (cadddr file))))))
- (let ((filenames (mapcar #'car system-description)))
- (sort modules #'(lambda (name1 name2)
- (member name2 (member name1 filenames)))
- :key #'module-name)))))
-
-
- (defun make-transformations (modules filter make-transform)
- (let ((transforms (list nil)))
- (dolist (m modules)
- (when (funcall filter m transforms) (funcall make-transform m transforms)))
- (reverse (cdr transforms))))
-
- (defun make-compile-transformation (module transforms)
- (unless (dolist (trans transforms)
- (and (eq (car trans) ':compile)
- (eq (cadr trans) module)
- (return t)))
- (dolist (c (module-comp-env module)) (make-load-transformation c transforms))
- (setf (cdr transforms)
- (remove-if #'(lambda (trans) (and (eq (car trans) :load)
- (eq (cadr trans) module)))
- (cdr transforms)))
- (push `(:compile ,module) (cdr transforms))))
-
- (defvar *being-loaded* ())
-
- (defun make-load-transformation (module transforms)
- (if (assoc module *being-loaded*)
- (throw module (setf (cdr transforms) (cdr (assoc module *being-loaded*))))
- (let ((*being-loaded* (cons (cons module (cdr transforms)) *being-loaded*)))
- (catch module
- (unless (dolist (trans transforms)
- (when (and (eq (car trans) ':load)
- (eq (cadr trans) module))
- (return t)))
- (dolist (l (module-load-env module))
- (make-load-transformation l transforms))
- (push `(:load ,module) (cdr transforms)))))))
-
- (defun make-load-without-dependencies-transformation (module transforms)
- (unless (dolist (trans transforms)
- (and (eq (car trans) ':load)
- (eq (cadr trans) module)
- (return trans)))
- (push `(:load ,module) (cdr transforms))))
-
- (defun compile-filter (module transforms)
- (or (dolist (r (module-recomp-reasons module))
- (when (dolist (transform transforms)
- (when (and (eq (car transform) ':compile)
- (eq (cadr transform) r))
- (return t)))
- (return t)))
- (null (probe-file (make-binary-pathname (module-name module))))
- (> (file-write-date (make-source-pathname (module-name module)))
- (file-write-date (make-binary-pathname (module-name module))))))
-
- (defun operation-transformations (name mode &optional arg)
- (let ((system (get-system name)))
- (unless system (error "Can't find system with name ~S." name))
- (let ((*system-directory* (funcall (car system)))
- (modules (cadr system)))
- (ecase mode
- (:compile
- ;; Compile any files that have changed and any other files
- ;; that require recompilation when another file has been
- ;; recompiled.
- (make-transformations
- modules
- #'compile-filter
- #'make-compile-transformation))
- (:recompile
- ;; Force recompilation of all files.
- (make-transformations
- modules
- #'true
- #'make-compile-transformation))
- (:recompile-some
- ;; Force recompilation of some files. Also compile the
- ;; files that require recompilation when another file has
- ;; been recompiled.
- (make-transformations
- modules
- #'(lambda (m transforms)
- (or (member (module-name m) arg)
- (compile-filter m transforms)))
- #'make-compile-transformation))
- (:query-compile
- ;; Ask the user which files to compile. Compile those
- ;; and any other files which must be recompiled when
- ;; another file has been recompiled.
- (make-transformations
- modules
- #'(lambda (m transforms)
- (or (compile-filter m transforms)
- (y-or-n-p "Compile ~A?"
- (module-name m))))
- #'make-compile-transformation))
- (:confirm-compile
- ;; Offer the user a chance to prevent a file from being
- ;; recompiled.
- (make-transformations
- modules
- #'(lambda (m transforms)
- (and (compile-filter m transforms)
- (y-or-n-p "Go ahead and compile ~A?"
- (module-name m))))
- #'make-compile-transformation))
- (:load
- ;; Load the whole system.
- (make-transformations
- modules
- #'true
- #'make-load-transformation))
- (:query-load
- ;; Load only those files the user says to load.
- (make-transformations
- modules
- #'(lambda (m transforms)
- (declare (ignore transforms))
- (y-or-n-p "Load ~A?" (module-name m)))
- #'make-load-without-dependencies-transformation))
- (:compile-load
- ;; Compile any files that have changed and any other files
- ;; that require recompilation when another file has been
- ;; recompiled. But if nothing requires compilation,
- ;; then load the whole system.
- (make-compile-load-transformations
- modules))))))
-
- (defun true (&rest ignore)
- (declare (ignore ignore))
- 't)
-
- (defun operate-on-system (name mode &optional arg print-only)
- (let ((system (get-system name)))
- (unless system (error "Can't find system with name ~S." name))
- (let* ((*system-directory* (funcall (car system)))
- (transformations (operation-transformations name mode arg)))
- (labels ((load-binary (name pathname)
- (format t "~&Loading binary of ~A...~%" name)
- (or print-only (load pathname)))
- (load-module (m)
- (let* ((name (module-name m))
- (*load-verbose* nil)
- (binary (make-binary-pathname name)))
- (load-binary name binary)))
- (compile-module (m)
- (format t "~&Compiling ~A...~%" (module-name m))
- (unless print-only
- (let ((name (module-name m)))
- (compile-file (make-source-pathname name)
- :output-file
- (make-pathname :defaults
- (make-binary-pathname name)
- :version :newest))))))
- (#+Genera
- compiler:compiler-warnings-context-bind
- #+TI
- COMPILER:COMPILER-WARNINGS-CONTEXT-BIND
- #+:LCL3.0
- lucid-common-lisp:with-deferred-warnings
- #+cmu
- with-compilation-unit #+cmu ()
- #-(or Genera TI :LCL3.0 cmu)
- progn
- (loop (when (null transformations) (return t))
- (let ((transform (pop transformations)))
- (ecase (car transform)
- (:compile (compile-module (cadr transform)))
- (:load (load-module (cadr transform)))))))))))
-
-
- (defun make-source-pathname (name) (make-pathname-internal name :source))
- (defun make-binary-pathname (name) (make-pathname-internal name :binary))
-
- (defun make-pathname-internal (name type)
- (let* ((extension (ecase type
- (:source (car *pathname-extensions*))
- (:binary (cdr *pathname-extensions*))))
- (directory (pathname
- (etypecase *system-directory*
- (string *system-directory*)
- (pathname *system-directory*)
- (cons (ecase type
- (:source (car *system-directory*))
- (:binary (cdr *system-directory*)))))))
- (pathname
- (make-pathname
- :name #-(and CLISP (or ATARI DOS)) (string-downcase (string name))
- #+(and CLISP (or ATARI DOS))
- (let ((name (remove #\- (string-upcase (string name)))))
- (if (> (length name) 8) (subseq name 0 8) name)
- )
- :type extension
- :defaults directory)))
-
- #+Genera
- (setq pathname (zl:send pathname :new-raw-name (pathname-name pathname))
- pathname (zl:send pathname :new-raw-type (pathname-type pathname)))
-
- pathname))
-
- (defun make-compile-load-transformations (modules)
- (let ((transforms (list nil)))
- (dolist (m modules)
- (when (compile-filter m transforms)
- (make-compile-transformation m transforms)))
- (if (cdr transforms)
- (reverse (cdr transforms))
- (make-transformations
- modules
- #'true
- #'make-load-transformation))))
-
- (defun system-source-files (name)
- (let ((system (get-system name)))
- (unless system (error "Can't find system with name ~S." name))
- (let ((*system-directory* (funcall (car system)))
- (modules (cadr system)))
- (mapcar #'(lambda (module)
- (make-source-pathname (module-name module)))
- modules))))
-
- (defun system-binary-files (name)
- (let ((system (get-system name)))
- (unless system (error "Can't find system with name ~S." name))
- (let ((*system-directory* (funcall (car system)))
- (modules (cadr system)))
- (mapcar #'(lambda (module)
- (make-binary-pathname (module-name module)))
- modules))))
-
- ;;; *** SITE SPECIFIC PCL DIRECTORY ***
- ;;;
- ;;; *pcl-directory* is a variable which specifies the directory pcl is stored
- ;;; in at your site. If the value of the variable is a single pathname, the
- ;;; sources and binaries should be stored in that directory. If the value of
- ;;; that directory is a cons, the CAR should be the source directory and the
- ;;; CDR should be the binary directory.
- ;;;
- ;;; By default, the value of *pcl-directory* is set to the directory that
- ;;; this file is loaded from. This makes it simple to keep multiple copies
- ;;; of PCL in different places, just load defsys from the same directory as
- ;;; the copy of PCL you want to use.
- ;;;
- ;;; Note that the value of *PCL-DIRECTORY* is set using a DEFVAR. This is
- ;;; done to make it possible for users to set it in their init file and then
- ;;; load this file. The value set in the init file will override the value
- ;;; here.
- ;;;
- ;;; *** ***
-
- (defun load-truename (&optional (errorp nil))
- #-(or Lispm excl Xerox (and dec vax common) LUCID akcl)
- (declare (ignore errorp))
- #-(or Lispm excl Xerox (and dec vax common) LUCID akcl) nil
- #+(or Lispm excl Xerox (and dec vax common) LUCID akcl)
- (flet ((bad-time ()
- (when errorp
- (error "LOAD-TRUENAME called but a file isn't being loaded."))))
- #+Lispm (or sys:fdefine-file-pathname (bad-time))
- #+excl excl::*source-pathname*
- #+Xerox (pathname (or (il:fullname *standard-input*) (bad-time)))
- #+(and dec vax common) (truename (sys::source-file #'load-truename))
- ;;
- ;; The following use of `lucid::' is a kludge for 2.1 and 3.0
- ;; compatibility. In 2.1 it was in the SYSTEM package, and i
- ;; 3.0 it's in the LUCID-COMMON-LISP package.
- ;;
- #+LUCID (or lucid::*source-pathname* (bad-time))
- #+akcl si:*load-pathname*
- ))
-
-
- #-(or cmu Symbolics CLISP)
- (defvar *pcl-directory*
- (or (load-truename t)
- (error "Because load-truename is not implemented in this port~%~
- of PCL, you must manually edit the definition of the~%~
- variable *pcl-directory* in the file defsys.lisp.")))
-
- #+cmu
- (defvar *pcl-directory* (pathname "pcl:"))
-
- #+coral
- (defvar *pcl-directory*
- ;; Example MCL pathnames.
- `(,(pathname "Harddisk0:MCL 2.0:July-92-PCL-beta:PCL Source:")
- . ,(pathname "Harddisk0:MCL 2.0:July-92-PCL-beta:PCL 1.3.2:")))
-
- #+Genera
- (defvar *pcl-directory*
- (let ((source (load-truename t)))
- (flet ((subdir (name)
- (scl:send source :new-pathname :raw-directory
- (append (scl:send source :raw-directory)
- (list name)))))
- (cons source
- #+genera-release-7-2 (subdir "rel-7-2")
- #+genera-release-7-3 (subdir "rel-7-3")
- #+genera-release-7-4 (subdir "rel-7-4")
- #+genera-release-8-0 (subdir "rel-8-0")
- #+genera-release-8-1 (subdir "rel-8-1")
- ))))
-
- #+Cloe-Runtime
- (defvar *pcl-directory* (pathname "/usr3/hornig/pcl/"))
-
- #+CLISP
- (defvar *pcl-directory*
- (or (load-truename t)
- (first (sys::search-file "defsys.lsp" nil))
- #+UNIX (pathname "~/lisp/pcl/")
- #+(or ATARI DOS) (pathname "\\LISP\\PCL\\")
- ) )
-
-
- (defsystem pcl
- *pcl-directory*
- ;;
- ;; file load compile files which port
- ;; environment environment force the of
- ;; recompilation
- ;; of this file
- ;;
- (
- ; (rel-6-patches t t () rel-6)
- ; (rel-7-1-patches t t () rel-7-1)
- (rel-7-2-patches t t () rel-7-2)
- (rel-8-patches t t () rel-8)
- (ti-patches t t () ti)
- (pyr-patches t t () pyramid)
- (xerox-patches t t () xerox)
- (kcl-patches t t () kcl)
- (ibcl-patches t t () ibcl)
- (gcl-patches t t () gclisp)
-
- (pkg t t ())
- (sys-proclaim t t () kcl)
- (walk (pkg) (pkg) ())
- (iterate t t ())
- (macros t t ())
- (low (pkg macros) t (macros))
-
-
- (genera-low (low) (low) (low) Genera)
- (cloe-low (low) (low) (low) Cloe)
- (lucid-low (low) (low) (low) Lucid)
- (Xerox-low (low) (low) (low) Xerox)
- (ti-low (low) (low) (low) TI)
- (vaxl-low (low) (low) (low) vaxlisp)
- (kcl-low (low) (low) (low) KCL)
- (ibcl-low (low) (low) (low) IBCL)
- (excl-low (low) (low) (low) excl)
- (cmu-low (low) (low) (low) CMU)
- (hp-low (low) (low) (low) HP-HPLabs)
- (gold-low (low) (low) (low) gclisp)
- (pyr-low (low) (low) (low) pyramid)
- (coral-low (low) (low) (low) coral)
- (clisp-low (low) (low) (low) CLISP)
-
- (fin t t (low))
- (defclass t t (low))
- (defs t t (defclass macros iterate))
- (fngen t t (low))
- (lap t t (low))
- (plap t t (low))
- (cpatch t t (low) excl-sun4)
- (quadlap t t (low) excl-sun4)
- (cache t t (low defs))
- (dlap t t (defs low fin cache lap))
- (boot t t (defs fin))
- (defgenerics t t (boot))
- (vector t t (boot defs cache fin))
- (slots t t (vector boot defs low cache fin))
- (init t t (vector boot defs low cache fin))
- (std-class t t (vector boot defs low cache fin slots))
- (str-class t t (vector boot defs low cache fin slots))
- (cpl t t (vector boot defs low cache fin slots))
- (braid t t (boot defs low fin cache))
- (fsc t t (defclass boot defs low fin cache))
- (methods t t (defclass boot defs low fin cache))
- (combin t t (defclass boot defs low fin cache))
- (dfun t t (dlap))
- (fixup (+ precom1 precom2) t (boot defs low fin))
- (defcombin t t (defclass boot defs low fin))
- (ctypes t t (defclass defcombin))
- (construct t t (defclass boot defs low))
- (env t t (defclass boot defs low fin))
- (compat t t ())
- (extensions t t ())
- (precom1 (dlap) t (defs low cache fin dfun))
- (precom2 (dlap) t (defs low cache fin dfun))
- ))
-
- (defun compile-pcl (&optional m)
- (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
- #+Lucid (lcl:*redefinition-action* nil)
- #+excl (excl::*redefinition-warnings* nil)
- #+Genera (sys:inhibit-fdefine-warnings t)
- )
- (cond ((null m) (operate-on-system 'pcl :compile))
- ((eq m :print) (operate-on-system 'pcl :compile () t))
- ((eq m :query) (operate-on-system 'pcl :query-compile))
- ((eq m :confirm) (operate-on-system 'pcl :confirm-compile))
- ((eq m 't) (operate-on-system 'pcl :recompile))
- ((listp m) (operate-on-system 'pcl :compile-from m))
- ((symbolp m) (operate-on-system 'pcl :recompile-some `(,m))))))
-
- (defun load-pcl (&optional m)
- (let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
- #+Lucid (lcl:*redefinition-action* nil)
- #+excl (excl::*redefinition-warnings* nil)
- #+Genera (sys:inhibit-fdefine-warnings t)
- )
- (cond ((null m) (operate-on-system 'pcl :load))
- ((eq m :query) (operate-on-system 'pcl :query-load)))))
-
- #+Genera
- ;;; Make sure Genera bug mail contains the PCL bug data. A little
- ;;; kludgy, but what the heck. If they didn't mean for people to do
- ;;; this, they wouldn't have made private patch notes be flavored
- ;;; objects, right? Right.
- (progn
- (scl:defflavor pcl-private-patch-info ((description)) ())
- (scl:defmethod (sct::private-patch-info-description pcl-private-patch-info) ()
- (or description
- (setf description (string-append "PCL version: " *pcl-system-date*))))
- (scl:defmethod (sct::private-patch-info-pathname pcl-private-patch-info) ()
- *pcl-directory*)
- (unless (find-if #'(lambda (x) (typep x 'pcl-private-patch-info))
- sct::*private-patch-info*)
- (push (scl:make-instance 'pcl-private-patch-info)
- sct::*private-patch-info*)))
-
- (defun bug-report-info (&optional (stream *standard-output*))
- (format stream "~&PCL system date: ~A~
- ~&Lisp Implementation type: ~A~
- ~&Lisp Implementation version: ~A~
- ~&*features*: ~S"
- *pcl-system-date*
- (lisp-implementation-type)
- (lisp-implementation-version)
- *features*))
-
-
-
- ;;;;
- ;;;
- ;;; This stuff is not intended for external use.
- ;;;
- (defun rename-pcl ()
- (dolist (f (cadr (get-system 'pcl)))
- (let ((old nil)
- (new nil))
- (let ((*system-directory* *default-pathname-defaults*))
- (setq old (make-source-pathname (car f))))
- (setq new (make-source-pathname (car f)))
- (rename-file old new))))
-
- #+Genera
- (defun edit-pcl ()
- (dolist (f (cadr (get-system 'pcl)))
- (let ((*system-directory* *pcl-directory*))
- (zwei:find-file (make-source-pathname (car f))))))
-
- #+Genera
- (defun hardcopy-pcl (&optional query-p)
- (let ((files (mapcar #'(lambda (f)
- (setq f (car f))
- (and (or (not query-p)
- (y-or-n-p "~A? " f))
- f))
- (cadr (get-system 'pcl))))
- (b zwei:*interval*))
- (unwind-protect
- (dolist (f files)
- (when f
- (multiple-value-bind (ignore b)
- (zwei:find-file (make-source-pathname f))
- (zwei:hardcopy-buffer b))))
- (zwei:make-buffer-current b))))
-
-
- ;;;
- ;;; unido!ztivax!dae@seismo.css.gov
- ;;; z30083%tansei.cc.u-tokyo.junet@utokyo-relay.csnet
- ;;; Victor@carmen.uu.se
- ;;; mcvax!harlqn.co.uk!chris@uunet.UU.NET
- ;;;
- #+Genera
- (defun mail-pcl (to)
- (let* ((original-buffer zwei:*interval*)
- (*system-directory* (pathname "vaxc:/user/ftp/pub/pcl/")
- ;(funcall (car (get-system 'pcl)))
- )
- (files (list* 'defsys
- 'test
- (caddr (get-system 'pcl))))
- (total-number (length files))
- (file nil)
- (number-of-lines 0)
- (i 0)
- (mail-buffer nil))
- (unwind-protect
- (loop
- (when (null files) (return nil))
- (setq file (pop files))
- (incf i)
- (multiple-value-bind (ignore b)
- (zwei:find-file (make-source-pathname file))
- (setq number-of-lines (zwei:count-lines b))
- (zwei:com-mail-internal t
- :initial-to to
- :initial-body b
- :initial-subject
- (format nil
- "PCL file ~A (~A of ~A) ~D lines"
- file i total-number number-of-lines))
- (setq mail-buffer zwei:*interval*)
- (zwei:com-exit-com-mail)
- (format t "~&Just sent ~A (~A of ~A)." b i total-number)
- (zwei:kill-buffer mail-buffer)))
- (zwei:make-buffer-current original-buffer))))
-
-
-
-